home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
rbbs_pc
/
rehash11.zip
/
REHASH.BAS
next >
Wrap
BASIC Source File
|
1990-10-04
|
7KB
|
251 lines
DECLARE FUNCTION HashTo% (V$, MaxPos%)
DECLARE FUNCTION ValidUser% (U$)
'* REHASH.BAS
'*---------------------------------------------------------------------------
'*
'* Quick 'N Dirty utility to auto-size/pack a RBBS users file
'*
'* 10-04-90
'*
ON ERROR GOTO 999
DEFINT A-Z
CONST FALSE = 0
CONST TRUE = -1
OPEN "CONS:" FOR OUTPUT AS #10
PRINT #10, "REHASH v1.10 10-04-90, Super-Dooper RBBS Users File Resizer, by Tom Collins"
PRINT #10,
A$ = COMMAND$
A$ = UCASE$(LTRIM$(RTRIM$(A$)))
ExemptLevel = 32000
I = INSTR(A$, "/EL")
IF I <> 0 THEN
ExemptLevel = VAL(MID$(A$, I + 3))
END IF
OlderThan = 32000
I = INSTR(A$, "/OT")
IF I <> 0 THEN
OlderThan = VAL(MID$(A$, I + 3))
END IF
ExtraUsers = 0
MultiplyFactor! = 1!
I = INSTR(A$, "/MF")
IF I <> 0 THEN
MultiplyFactor! = VAL(MID$(A$, I + 3))
IF MultiplyFactor! < 1! OR MultiplyFactor! > 10! THEN
MultiplyFactor! = 1!
END IF
END IF
IF MultiplyFactor! = 1! THEN
ExtraUsers = 8
END IF
I = INSTR(A$, "/EU")
IF I <> 0 THEN
X = VAL(MID$(A$, I + 3))
IF X > 0 THEN
ExtraUsers = X
END IF
END IF
I = INSTR(A$, "/")
IF I <> 0 THEN
A$ = LEFT$(A$, I - 1)
END IF
I = INSTR(A$, " ")
IF A$ = "" OR I = 0 THEN
PRINT #10, "Usage: REHASH <Messages File> <Users File> [/ELx] [/OTx] [/MFx] [/EUx]"
PRINT #10, " /ELx - Users >= Level x are exempt from packing"
PRINT #10, " /OTx - Remove users who haven't been on in x days"
PRINT #10, " /MFx - Keep file size at least x times what's required (x > 1.0)"
PRINT #10, " /EUx - Leave room for at least x more users"
END
END IF
TempFile$ = "$$USERS$.$$$"
100 MsgsFile$ = RTRIM$(LTRIM$(LEFT$(A$, I)))
OPEN MsgsFile$ FOR RANDOM AS #1 LEN = 128
FIELD 1, 128 AS M$
110 UsersFile$ = RTRIM$(LTRIM$(MID$(A$, I)))
OPEN UsersFile$ FOR RANDOM AS #2 LEN = 128
FIELD 2, 128 AS U$
UserRecs = LOF(2) \ 128
IF MID$(UsersFile$, 2, 1) = ":" THEN
TempFile$ = LEFT$(UsersFile$, 2) + TempFile$
END IF
120 PRINT #10, CHR$(254) + " Reading "; UsersFile$; "...";
UsersRecsUsed = 0
TempRecs$ = ""
FOR I = 1 TO UserRecs
GET #2, I
IF ValidUser(U$) THEN
UserRecsUsed = UserRecsUsed + 1
TempRecs$ = TempRecs$ + MKI$(I)
END IF
NEXT
PRINT #10, UserRecsUsed; "of"; UserRecs; "Records Used."
IF MultiplyFactor! = 1! THEN
UserRecsRequired = UserRecsUsed + ExtraUsers
ELSE
UserRecsRequired = MultiplyFactor! * UserRecsUsed
IF UserRecsRequired - UserRecsUsed < ExtraUsers THEN
UserRecsRequired = UserRecsUsed + ExtraUsers
END IF
END IF
FOR I = 3 TO 15
IF I = 14 THEN
PRINT #10, CHR$(254) + " Can't Rehash..."
CLOSE 1, 2
END
END IF
IF 2 ^ I > UserRecsRequired THEN
UserRecsRequired = 2 ^ I
EXIT FOR
END IF
NEXT
IF UserRecsRequired = UserRecs THEN
PRINT #10, CHR$(254) + " No Resizing Required..."
CLOSE 1, 2
END
END IF
130 PRINT #10, CHR$(254) + " Resizing File to"; UserRecsRequired; "Records... ";
Recs$ = TempRecs$
OPEN TempFile$ FOR RANDOM AS #3 LEN = 128
FIELD 3, 128 AS T$
140 LSET T$ = SPACE$(128)
150 FOR I = 1 TO UserRecsRequired
PUT 3, I
NEXT
WHILE Recs$ <> ""
I = CVI(LEFT$(Recs$, 2))
Recs$ = MID$(Recs$, 3)
160 GET #2, I
X = HashTo(U$, UserRecsRequired)
IF X = -1 THEN
PRINT #10, "Failed."
170 CLOSE 3
IF UserRecsRequired = 16384 THEN
PRINT #10, CHR$(254) + " Can't Rehash..."
CLOSE 1, 2
END
END IF
UserRecsRequired = UserRecsRequired * 2
GOTO 130
END IF
' PRINT #10, " "; RTRIM$(LEFT$(U$, 31)); ":"; I; "->"; X
180 LSET T$ = U$
190 PUT 3, X
WEND
CLOSE 2, 3
200 KILL UsersFile$
210 NAME TempFile$ AS UsersFile$
220 GET 1, 1
MID$(M$, 57, 5) = STR$(UserRecsUsed)
230 PUT 1, 1
240 CLOSE 1
PRINT #10, "Done."
END
999 IF ERL = 100 THEN
PRINT #10, "Can't Find Messages File '"; MsgsFile$; "'..."
END
ELSEIF ERL = 110 THEN
PRINT #10, "Can't Find Users File '"; UsersFile$; "'..."
END
ELSE
PRINT #10, "Weird Error"; ERR; "at Line"; ERL; "Has Occurred..."
END
END IF
'* HASHTO
'*---------------------------------------------------------------------------
'*
'* Returns the user record to put a given user, or -1 if no more room
'*
'*
FUNCTION HashTo (V$, MaxPos)
UserName$ = RTRIM$(LEFT$(V$, 31))
L = LEN(UserName$)
EmptyRec$ = SPACE$(31)
SecondHash = (ASC(MID$(UserName$, 2, 1)) * 10 + 7) MOD MaxPos
PrimeHash = ASC(MID$(UserName$, 1, 1)) * 100
PrimeHash = PrimeHash + ASC(MID$(UserName$, L / 2 + .1, 1)) * 10
PrimeHash = PrimeHash + ASC(RIGHT$(UserName$, 1))
PrimeHash = (PrimeHash MOD MaxPos) + 1
FIELD 3, 128 AS T$
I = PrimeHash
Found = FALSE
FOR Count = 1 TO 25
IF I <= 0 THEN
EXIT FOR
END IF
300 GET 3, I
IF LEFT$(T$, 31) = EmptyRec$ THEN
HashTo = I
Found = TRUE
EXIT FOR
END IF
I = I + SecondHash
IF I > MaxPos - 1 THEN
I = I - MaxPos
END IF
NEXT
IF NOT Found THEN
HashTo = -1
END IF
END FUNCTION
'* VALIDUSER
'*---------------------------------------------------------------------------
'*
'* Returns TRUE or FALSE depending on whether a given user should
'* be kept in the users file.
'*
FUNCTION ValidUser (U$)
SHARED OlderThan, ExemptLevel
B$ = LEFT$(U$, 31)
ValidUser = TRUE
IF MID$(B$, 2, 12) = "deleted user" OR LEFT$(B$, 7) = "NEWUSER" THEN
ValidUser = FALSE
ELSEIF B$ = SPACE$(31) OR B$ = STRING$(31, 0) THEN
ValidUser = FALSE
ELSE
D$ = DATE$
DaysOld = (VAL(MID$(D$, 9, 2)) - VAL(MID$(U$, 112, 2))) * 365 ' YY
DaysOld = DaysOld + (VAL(MID$(D$, 1, 2)) - VAL(MID$(U$, 106, 2))) * 30 ' MM
DaysOld = DaysOld + VAL(MID$(D$, 4, 2)) - VAL(MID$(U$, 109, 2)) ' DD
IF DaysOld > OlderThan THEN
UserSecLevel = CVI(MID$(U$, 47, 2))
IF UserSecLevel < ExemptLevel THEN
ValidUser = FALSE
END IF
END IF
END IF
END FUNCTION